home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / Float source / fArgs < prev    next >
Text File  |  1990-12-22  |  6KB  |  165 lines
  1. \ support for floating point named input parms
  2. \  9/22/85  cbd Version 1.0
  3. \ 12/03/87    rfl added ;m
  4.  
  5. \ fetch the 0th floating point arg  
  6. :CODE @fp0
  7.         move.l  YERK[(fltNew)],d7  
  8.         jsr     0(a3,d7.l)          ; get new float in d1
  9.         clr.l   d0
  10.         move.l  d5,a2               ; get mstack
  11.         move.l  8(a2),d0            ; get float value
  12.         lea     2(a3,d0.l),a0       ; get addr of arg's data
  13.         lea     2(a3,d1.l),a1       ; get addr of new float's data
  14.         move.l  (a0)+,(a1)+
  15.         move.l  (a0)+,(a1)+
  16.         move.w  (a0)+,(a1)+
  17.         move.l  d1,-(a7)            ; push the new float
  18. ;CODE
  19.  
  20. :CODE @fp1
  21.         move.l  YERK[(fltNew)],d7  
  22.         jsr     0(a3,d7.l)          ; get new float in d1
  23.         clr.l   d0
  24.         move.l  d5,a2               ; get mstack
  25.         move.l  12(a2),d0            ; get float value
  26.         lea     2(a3,d0.l),a0       ; get addr of arg's data
  27.         lea     2(a3,d1.l),a1       ; get addr of new float's data
  28.         move.l  (a0)+,(a1)+
  29.         move.l  (a0)+,(a1)+
  30.         move.w  (a0)+,(a1)+
  31.         move.l  d1,-(a7)            ; push the new float
  32. ;CODE
  33.  
  34. \ fetch the floating point arg whose offset is at the IP
  35. :CODE @fp2
  36.         move.l  YERK[(fltNew)],d7  
  37.         jsr     0(a3,d7.l)          ; get new float in d1
  38.         clr.l   d0
  39.         move.l  d5,a2               ; get mstack
  40.         move.l  16(a2),d0            ; get float value
  41.         lea     2(a3,d0.l),a0       ; get addr of arg's data
  42.         lea     2(a3,d1.l),a1       ; get addr of new float's data
  43.         move.l  (a0)+,(a1)+
  44.         move.l  (a0)+,(a1)+
  45.         move.w  (a0)+,(a1)+
  46.         move.l  d1,-(a7)            ; push the new float
  47. ;CODE
  48.  
  49. \ fetch the floating point arg whose offset is at the IP
  50. :CODE @fp3
  51.         move.l  YERK[(fltNew)],d7  
  52.         jsr     0(a3,d7.l)          ; get new float in d1
  53.         clr.l   d0
  54.         move.l  d5,a2               ; get mstack
  55.         move.l  20(a2),d0            ; get float value
  56.         lea     2(a3,d0.l),a0       ; get addr of arg's data
  57.         lea     2(a3,d1.l),a1       ; get addr of new float's data
  58.         move.l  (a0)+,(a1)+
  59.         move.l  (a0)+,(a1)+
  60.         move.w  (a0)+,(a1)+
  61.         move.l  d1,-(a7)            ; push the new float
  62. ;CODE
  63.  
  64. \ fetch the floating point arg whose offset is at the IP
  65. :CODE @fp4
  66.         move.l  YERK[(fltNew)],d7  
  67.         jsr     0(a3,d7.l)          ; get new float in d1
  68.         clr.l   d0
  69.         move.l  d5,a2               ; get mstack
  70.         move.l  24(a2),d0            ; get float value
  71.         lea     2(a3,d0.l),a0       ; get addr of arg's data
  72.         lea     2(a3,d1.l),a1       ; get addr of new float's data
  73.         move.l  (a0)+,(a1)+
  74.         move.l  (a0)+,(a1)+
  75.         move.w  (a0)+,(a1)+
  76.         move.l  d1,-(a7)            ; push the new float
  77. ;CODE
  78.  
  79. \ fetch the floating point arg whose offset is at the IP
  80. :CODE @fp5
  81.         move.l  YERK[(fltNew)],d7  
  82.         jsr     0(a3,d7.l)          ; get new float in d1
  83.         clr.l   d0
  84.         move.l  d5,a2               ; get mstack
  85.         move.l  28(a2),d0            ; get float value
  86.         lea     2(a3,d0.l),a0       ; get addr of arg's data
  87.         lea     2(a3,d1.l),a1       ; get addr of new float's data
  88.         move.l  (a0)+,(a1)+
  89.         move.l  (a0)+,(a1)+
  90.         move.w  (a0)+,(a1)+
  91.         move.l  d1,-(a7)            ; push the new float
  92. ;CODE
  93.  
  94. \ store a new float in the arg whose offset is at the IP
  95. :CODE   !fp(ip)
  96.         move.w  (a4)+,d2            ; pickup arg offset
  97.         move.l  d5,a2               ; get mstack
  98.         move.l  0(a2,d2.w),d0       ; get old float value
  99.         beq     noDisp              ; if 0, don't dispose
  100.         move.l  YERK[(fltDisp)],d7
  101.         jsr     0(a3,d7.l)          ; dispose of old float
  102. noDisp  move.l  (a7)+,0(a2,d2.w)    ; store new float in mstack cell
  103. ;CODE
  104.  
  105. \ add a float to the arg whose offset is at the IP
  106. :CODE   +fp(ip)
  107.         move.w  (a4)+,d2            ; pickup arg offset
  108.         move.l  d5,a2               ; get mstack
  109.         move.l  0(a2,d2.w),d1       ; get contents of arg in d1 = rcvr
  110.         beq     notInit             ; if 0, don't proceed
  111.         move.l  (a7)+,d0            ; get parm
  112.         pea     2(a3,d0.l)          ; push parm absolute
  113.         pea     2(a3,d1.l)          ; push rcvr absolute
  114.         move.l  YERK[(fltDisp)],d7  ; get subr addr in d7
  115.         jsr     0(a3,d7.l)          ; go dispose of parm in d0
  116.         clr.w   -(A7)               ; code for FADD
  117.         call pack4
  118.         move.l  (a4)+,d6            ; do next
  119.         move.l  0(a3,d6.l),d7
  120.         jmp     0(a3,d7.l) 
  121. notInit  move.l #3,d1                
  122.         move.l  YERK[fpErr],d7
  123.         move.l  YERK[execWord],d6
  124.         jmp     0(a3,d6.l)                
  125. ;CODE
  126.  
  127. \ deallocate the floats held in named input args.  This cfa
  128. \ is compiled before (;m) in words that have float args.  A 16-bit word at
  129. \ the IP holds a bitmask indicating which args are float.
  130. :CODE  killFargs
  131.         move.w  (a4)+,d2        ; get bitmask
  132.         move.l  d5,a2           ; get mstack
  133.         move.l  YERK[(fltDisp)],d7
  134.         addq.l  #8,a2           ; point to 0th arg
  135. kf1     asr.w   #1,d2           ; shift low bit into carry
  136.         bcc     noDisp          ; if carry clear, not a float
  137.         beq     kfLast          ; if 0, no more to shift
  138.         move.l  (a2),d0         ; get the float
  139.         beq     noDisp          ; skip uninitialized floats
  140.         jsr     0(a3,d7.l)      ; kill it
  141. noDisp  addq.l  #4,a2           ; next cell
  142.         bra     kf1             ; loop 
  143. kfLast  move.l  (a2),d0         ; get the float
  144.         jsr     0(a3,d7.l)      ; kill it
  145. ;CODE  
  146.         
  147. 'c @fp0  fpicks !
  148. 'c @fp1  fpicks 4+ !
  149. 'c @fp2  fpicks 8+ !
  150. 'c @fp3  fpicks 12 + !
  151. 'c @fp4  fpicks 16 + !
  152. 'c @fp5  fpicks 20 + !
  153.  
  154. 'c !fp(ip)  -> farg!
  155. 'c +fp(ip)  -> farg++
  156. 'c killfargs -> fkill
  157.  
  158. \ ;M checks if the latest method has named float args, and if so,
  159. \ compiles the float disposal routine before the end of the method.
  160. : ;M   ?csp ?class  ^class mfa @ 14 + dup c@
  161.     IF  1+ c@  dup IF fkill , w,  ELSE drop THEN
  162.     ELSE  drop 
  163.     THEN  compile (;m) ;  immediate
  164.  
  165.